{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.FreshMon
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Monad supplying fresh identifiers plus error 
-- reporting.
--
--------------------------------------------------------------------------------


module WumpusExpr.FreshMon
  ( 

    ErrMsg
  , Mon
  , runMon

  , fresh
  , refresh
  , throwError

  ) where

import WumpusExpr.Types
import WumpusExpr.VarId

import Control.Applicative

type ErrMsg = String


newtype Mon a = Mon { getMon :: Int -> Either ErrMsg (a,Int) }

instance Functor Mon where
  fmap f ma = Mon $ \s -> getMon ma s >>= \(a,s1) -> return (f a, s1)

instance Applicative Mon where
  pure a    = Mon $ \s -> return (a,s)
  af <*> av = Mon $ \s -> getMon af s  >>= \(f,s1) ->
                          getMon av s1 >>= \(a,s2) ->
                          return (f a,s2)

instance Monad Mon where
  return = pure
  ma >>= k = Mon $ \s -> getMon ma s >>= \(a,s1) -> getMon (k a) s1


runMon :: Mon a -> Either ErrMsg a
runMon ma = fmap fst $ getMon ma 1


fresh :: Type -> Mon VarId
fresh ty = Mon $ \i -> return (SynthId i ty, i+1)

-- | Add a fresh subscript to the variable name.
--
refresh :: VarId -> Mon VarId
refresh (SynthId _ ty) = Mon $ \i -> return (SynthId i ty, i+1)
refresh prim           = Mon $ \i -> return (prim, i)


throwError :: ErrMsg -> Mon a
throwError err = Mon $ \_ -> Left err
